perm filename TOP4[AM,DBL] blob
sn#183507 filedate 1975-10-24 generic text, type T, neo UTF8
(FILECREATED "24-OCT-75 03:24:59" <LENAT>TOP4.;48 57318
changes to: ACEX-OLD START FIL-ACEX FIL-EX1 FIL-EX2 INSTAN-1D PICK-CAND SOME-EBP UP-THRESH ACEX APPLYB RANDQMEMB
RECTANGLE VERBOSITY
previous date: "22-OCT-75 03:31:36" <LENAT>TOP4.;46)
(LISPXPRINT (QUOTE TOP4COMS)
T T)
[RPAQQ TOP4COMS
((FNS ACCESS ACEX ACEX-OLD ADD-CANDS ALL-BUT-LAST ALLQ ANY1OF ANY1OF-SATISFYING ANY1OFE ANY1SAT APPENDB APPLYB
APPLYB-P AQ-LIST ARE-EQUIV ARG-CHECK ARG-SUBST ARGS-ASA AVG2 BLOWUP-COALES BLOWUP-INTERESTING-SPEC BOOST
BPFS COM-ANCES COMMENT CON-MERGE-ARGS CPRIN1 CREATEB DE-THRESH DECRB DEFB DEFP DIE DOTPROD DRAND-PERMUTE
DWIMUSERFN ENSURE ENSURE-TOP EVERY2 EXA FAN FIL-ACEX FIL-EX1 FIL-EX2 FIL-STRUC-P FIND-NEW-CANDS FIRSTN
FLATTEN FOU FOU1 FRAC-INCLU FSET-NTH GATH GCB GEN-FNAME GET-TIME GETARGS GETB GETB-P GETB-P-C GETBQ GETU
GEXADD GEXEC GINIT GLUE GLUEC GLUEE GPGM-PRIN GTRANSFER HANDLE-I HANDLE-I-INTERRUPT HANDLE-N IN-FACTOR
INCRB INIT-PART INSTAN-1D INSTAN-1I INSTAN-1S INSTAN-ACT-TRANS INSTAN-BASE INSTAN-D INSTAN-I INSTAN-PAT
INSTAN-REC INSTAN-S INSTAN-TRANSF INT-ENUF INT-PREDS IS-CON IS-CON-L IS-ONE-OF ISA JUST-ONCE KINDS-OF
LARGER LESS-INT LRU-TAG M2 MAPAPPEND MAX MAX1 MAX2 MAXI MIN2 MKSWAPP MORE-GENERAL MORE-INT MORE-SPECIFIC
NCONCB NO-COMMEN ONE-ISA ONLY-COMS PGET PICK-CAND POR PRUNABLE PRUNE PSUF PUTB PUTU PXEQ Q RAND-CON
RAND-MEMB RAND-OBJ RAND-PERMUTE RAND-PRED RAND-SUBSET RAND-THING RAND-USER RANDQMEMB RE-JUDGE READ-LOOP
READ1CHAR RECENTLY-TRIED RECTANGLE REM-ONCE RIPPLE RIPPLE-SIMULT RIPPLE-UNTIL RIPPLE1 RMUL RUN-COMM
RUN-COMM-IF-MUST SAME-TYPE SATISFIES SELF SELF-COMPILE SELF-INT SEQX SET-DIFF SET-DIFFERENCE SET-NTH
SETB SETB-I SETBQ SIMULT-SATISFY SMALLER SOME-EBP SOMEE SORD SORV SSORT START STRUCTYP? SUB-CANDS
SUB-ONCE SUBSET-INVOLVING-ONLY SWAPB SWGETB SWITCH SWSETB TAG-DOMAIN TAG-RANGE TLOOP TYPE UNDO-INIT
UNFORGETTABLE UNPRUNABLE UP-THRESH UPDATE XEQ-CAND XTR-AC-EX XTR-BEING)
(FNS INIT1 INIT-COMP)
BA-LIST BA-LIST2 CAND-TAIL COMMA CONSTRUCTIVE-OPS CRLF DO-THRESH DWIMUSERFN EX-THRESH F-COUNTER GNUMS
INIT-CANDS INIT-ONCE-LIST INIT-PAST INIT-DOTHRESH INIT-EXTHRESH INIT-INT-THRESH INIT-INTHRESH INT-THRESH
INTHRESH JTRASH RANDSTATE TKNT-INIT TOP-ACTS TRIVB USERNAMES VERBOSITY (P (INIT1)
(INIT-COMP))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA TYPE COMMENT ANY1OF)
(NLAML SWITCH SETBQ SELF-COMPILE SELF RE-JUDGE Q JUST-ONCE GETBQ AQ-LIST ANY1SAT ALLQ]
(DEFINEQ
(ACCESS
[LAMBDA (A)
A])
(ACEX
[NLAMBDA (B)
(OR (IS-CON B)
(SETQ B (EVAL B)))
(COND
((AND (EQ B ACEX-OLDB)
(ILESSP GCNT ACEXPIRE))
ACEX-OLDV)
(T (SETQ ACEX-OLDB B)
(SETQ ACEXPIRE (IPLUS 3 GCNT))
(SETQ ACEX-OLDV (OR [RUN-COMM-IF-MUST (XTR-AC-EX (GETB B (QUOTE EXS]
(RUN-COMM-IF-MUST (XTR-AC-EX (APPLY* (QUOTE EXS)
B)))
(BOOST (QUOTE FILLIN)
B
(QUOTE EXS])
(ACEX-OLD
[LAMBDA (B)
(OR [RUN-COMM-IF-MUST (XTR-AC-EX (GETB B (QUOTE EXS]
(RUN-COMM-IF-MUST (XTR-AC-EX (APPLY* (QUOTE EXS)
B])
(ADD-CANDS
[LAMBDA (C)
(SETQ CANDS (NCONC C CANDS])
(ALL-BUT-LAST
[LAMBDA (L)
(LDIFF L (FLAST L])
(ALLQ
[NLAMBDA (L)
(COND
((NLISTP L)
(KWOTE L))
((CONS (QUOTE LIST)
(MAPCAR L (QUOTE ALLQ])
(ANY1OF
[NLAMBDA Z (* EVAL (RAND-MEMB Z))
(EVAL (CAR Z])
(ANY1OF-SATISFYING
[LAMBDA (XSET TST X)
(AND (SETQ X (RAND-MEMB XSET))
(COND
((EVAL TST)
X)
((ANY1OF-SATISFYING (REMOVE X XSET)
TST])
(ANY1OFE
[LAMBDA (L)
(CAR L])
(ANY1SAT
[NLAMBDA (XSET TST)
(ANY1OF-SATISFYING (EVAL XSET)
TST])
(APPENDB
[LAMBDA (B P L)
(AND L (INCRB B P (CAR L))
(APPENDB B P (CDR L])
(APPLYB-P
[LAMBDA (B)
(APPLYB B P BA1 BA2 BA3 BA4])
(AQ-LIST
[NLAMBDA (B A1 A2 A3 A4)
(LIST (QUOTE APPLYB)
(KWOTE (EVAL B))
(Q ALGS)
A1 A2 A3 A4])
(ARE-EQUIV
[LAMBDA (X1 X2)
(OR (EQUAL X1 X2)
(MEMBER (LIST (QUOTE EQUIV)
X1)
(GETB X2 (QUOTE TIES)))
(INTERSECTION (GETB X1 (QUOTE DEFN))
(GETB X2 (QUOTE DEFN)))
(INTERSECTION (GETB X1 (QUOTE ALGS))
(GETB X2 (QUOTE ALGS)))
(ADD-CANDS (LIST (LIST CS-INT (QUOTE FILLIN)
(QUOTE PROVE)
(LIST (QUOTE FORALL)
(QUOTE ARGS)
(LIST (QUOTE EQUAL)
(KWOTE BA1)
(KWOTE BA2)))
(QUOTE INDUCTIVELY))
(CONS (SUB1 CS-INT)
(APPEND (CDR CAND)
(LIST (QUOTE DO-AGAIN])
(ARG-CHECK
[LAMBDA (A B)
(EVERY2 [CDR (ANY1OF (GETB B (QUOTE D-R]
A
(QUOTE DEFN])
(ARG-SUBST
[LAMBDA (ARG1 NEW1 ARG2 NEW2)
[SET ARG1 (CAR (DSUBST NEW1 ARG1 (DSUBST NEW1 (LIST (QUOTE COPY)
ARG1)
(DSUBST NEW2 ARG2 (DSUBST NEW2 (LIST (QUOTE COPY)
ARG2)
(LIST (COPY (EVAL ARG1]
(SET ARG2 (CAR (DSUBST NEW1 ARG1 (DSUBST NEW1 (LIST (QUOTE COPY)
ARG1)
(DSUBST NEW2 ARG2 (DSUBST NEW2 (LIST (QUOTE COPY)
ARG2)
(LIST (COPY (EVAL ARG2])
(ARGS-ASA
[LAMBDA (BNAME ARGSET) (* HERE WE ARE SUPPOSED TO LOCATE THE
D-R PART OF BNAME, AND BIND THE
ARGUMENTS ON (CDR OF) ARGLIST AS
SPECIFIED IN THAT D-R PART)
(HELP "ARGS-ASA IS NOT IN YET. SORRY. "])
(AVG2
[LAMBDA (N1 N2)
(IQUOTIENT (IPLUS N1 N2)
2])
(BLOWUP-COALES
[LAMBDA (BA1 NNAM)
(AND (CREATEB NNAM) (* NNAM now names new Being)
[SETQ GTEMP213 (LAST (CAR (GETB BA1 (QUOTE D-R] (* GTEMP213 holds the range component of
the Active BA1)
(SETQ GTEMP212 (LDIFF (CAR (GETB BA1 (QUOTE D-R)))
GTEMP213)) (* GTEMP212 now holds a list of the
domain components for BA1)
(SETQ GTEMP214 (RAND-PERMUTE (FMEMB (LENGTH GTEMP212)
GNUMS)))
(SETQ GTEMP215 (RAND-PERMUTE (FMEMB (LENGTH GTEMP212)
GNUMS))) (* GTEMP214 and GTEMP215 are random
permutation of 1,2,..., up to the number
of domain components.)
[SETQ GTEMP219 (CAR (SOME GTEMP214 (FUNCTION (LAMBDA (N)
(SETQ GTEMP216 (CAR (FNTH GTEMP212 N)))
(SETQ GTEMP220 (CAR (SOME (REMOVE N GTEMP215)
(FUNCTION (LAMBDA (M)
(SETQ GTEMP217 (CAR (FNTH GTEMP212 M)))
(OR (ISA GTEMP216 GTEMP217)
(AND (ISA GTEMP217 GTEMP216)
(SETQ GSWI T]
(* GTEMP219 and GTEMP220 are the
positions, and GTEMP216 and GTEMP217 are
the corresponding names, of the 2 domain
components to be coalesced.)
(COND
(GSWI (SWITCH GTEMP216 GTEMP217)
(SWITCH GTEMP219 GTEMP220))
(T))
(SET-NTH GTEMP212 GTEMP220 GTEMP216) (* NOW GTEMP216 AND GTEMP219 REFER TO A
MORE SPECIFIC BEING THAN GTEMP217 AND
GTEMP220)
(SETQ GTEMP221 (LARGER GTEMP219 GTEMP220))
(INCRB NNAM (QUOTE D-R)
(APPEND (FIRSTN (SUB1 GTEMP221)
GTEMP212)
(FNTH GTEMP212 (ADD1 GTEMP221))
GTEMP213))
[INCRB NNAM (QUOTE ALGS)
(SETQ GTEMP224 (LIST (QUOTE TYPE)
(QUOTE TRANSFORM)
(QUOTE REDUCING-TO)
BA1
(APPEND (LIST (QUOTE APPLYB)
(KWOTE BA1)
(Q ALGS))
(FIRSTN (SUB1 GTEMP221)
BA-LIST)
[LIST (SETQ GTEMP222 (PACK (LIST (QUOTE BA)
(SMALLER GTEMP219 GTEMP220]
(SETQ GTEMP223 (FIRSTN (IDIFFERENCE (LENGTH GTEMP212)
GTEMP221)
(FNTH BA-LIST GTEMP221]
[SETB NNAM (QUOTE WORTH)
(APPEND (GETB BA1 (QUOTE WORTH]
(INCRB NNAM (QUOTE GENL)
BA1)
(INCRB BA1 (QUOTE SPEC)
NNAM)
(INCRB NNAM (QUOTE DEFN)
GTEMP224)
(INCRB NNAM (QUOTE ALGS)
(SUBPAIR (FIRSTN (ADD1 (LENGTH GTEMP223))
(FNTH BA-LIST GTEMP221))
(CONS GTEMP222 GTEMP223)
(CADR (GETB BA1 (QUOTE ALGS)))
T))
NNAM])
(BLOWUP-INTERESTING-SPEC
[LAMBDA (BA1 BA2)
(CREATEB NEWB)
(INCRB NEWB (QUOTE GENL)
CS-B)
(INCRB CS-B (QUOTE SPEC)
NEWB)
[INCRB NEWB (QUOTE DEFN)
(LIST (QUOTE TYPE)
(QUOTE TRANSFORM)
(QUOTE REDUCING-TO)
CS-B
(CONS (QUOTE AND)
(APPEND GTEMP9 (LIST (LIST (QUOTE APPLYB)
(KWOTE CS-B)
(Q DEFN)
(QUOTE BA1)
(QUOTE BA2)
(QUOTE BA3)
(QUOTE BA4]
(SETQ TMP6 0)
(APPENDB NEWB (QUOTE INT)
GREM) (* This is a strong form of tracing to
see why (1) (1) (1))
[NCONC (CADR (GETB NEWB (QUOTE INT)))
(MAPCAR GREM (FUNCTION (LAMBDA (Z)
(LIST (SETQ TMP6 (ADD1 TMP6]
(SETB NEWB (QUOTE WORTH)
(PROGN [SETQ GTEMP4 (APPEND (GETB CS-B (QUOTE WORTH]
(SET-NTH GTEMP4 1 (AVG2 NEW-ILEV (CAR GTEMP4)))
[COND
((NUMBERP (CAR (FNTH GTEMP4 11)))
(SET-NTH GTEMP4 11 (LIST (QUOTE COND)
(LIST (LIST (QUOTE GETB)
(KWOTE NEWB)
(KWOTE (QUOTE EXS)))
(ADD1 (CAR (FNTH GTEMP4 11]
GTEMP4))
(AND (ISA CS-B (QUOTE ACTIVE))
[SETQ BAL1 (ALL-BUT-LAST (ANY1OFE (GETB CS-B (QUOTE D-R]
(SETQ TMP1 (SELECTQ (LENGTH BAL1)
(0 (CPRIN1 2 "Anyb-exs . Fillin2 has come across an active with no args." CRLF "CS-B is "
CS-B ". NEWB is " NEWB CRLF))
(1 (FIL-EX1 BA1 BA2 NEWB))
(2 (FIL-EX2 BA1 BA2 NEWB))
(CPRIN1
"Sorry. ANYB-EXS . FILLIN2 has come across an active whose domain
is longer than 2 components. I am not yet implemented for this. I lose. " CRLF "CS-B is " CS-B ". NEWB is " NEWB CRLF))
)
(INCRB NEWB (QUOTE ALGS)
(LIST (QUOTE TYPE)
(QUOTE QUASIRECURSIVE)
(QUOTE CASES)
(QUOTE REDUCING-TO)
CS-B
(CONS (QUOTE COND)
TMP1)))
(INCRB NEWB (QUOTE D-R)
[APPEND (CAR (GETB CS-B (QUOTE D-R] (* NOTE: Later, we must fix this up so
it realy knows what the new D-R is.)
))
(ADD-CANDS (LIST (LIST (SUB1 CS-INT)
(QUOTE FILLIN)
NEWB
(QUOTE EXS])
(BOOST
[LAMBDA (A B C)
(ADD-CANDS (LIST (LIST CS-INT A B C)))
NIL])
(BPFS
[LAMBDA (B)
(CDDR (CADDR (GETD B])
(COM-ANCES
[LAMBDA (B1 B2 ANLIST)
[MAP2C (DREVERSE (RIPPLE B1 (QUOTE GENL)))
(DREVERSE (RIPPLE B2 (QUOTE GENL)))
(FUNCTION (LAMBDA (AN1 AN2)
(AND (EQ AN1 AN2)
(SETQ ANLIST (CONS AN1 ANLIST]
ANLIST])
(COMMENT
[NLAMBDA X
(CONS (QUOTE COMMENT)
X])
(CON-MERGE-ARGS
[LAMBDA (F1 F2 F12 PGM1 SCHK SAPL DOM1 DOM2 RAN1 RAN2)
[SETQ RAN1 (LAST (CAR (GETB F1 (QUOTE D-R]
(SETQ DOM1 (LDIFF (CAR (GETB F1 (QUOTE D-R)))
RAN1))
[SETQ RAN2 (LAST (CAR (GETB F2 (QUOTE D-R]
(SETQ DOM2 (LDIFF (CAR (GETB F2 (QUOTE D-R)))
RAN2)) (* SETQ DOM3 (AND (CDR DOM1)
(LIST (CADR (MIN2 (APPEND RAN2 RAN2 RAN2
RAN2) DOM1 (QUOTE FRAC-INCLU))))))
(COMMENT AS DOMi AND RANi ARE LOCATED, SWITCHING OF ARGS MAY BE REQUIRED, INSIDE PGM1)
(* AND (MEMB (CAR DOM3) DOM2)
(SETQ DOM3 NIL))
(SETQ GTEMP20 (LENGTH DOM2))
[SETQ SAPL (LIST (QUOTE RETURN)
(NCONC (LIST (QUOTE APPLYB)
(KWOTE F1)
(Q ALGS))
(MAPCAR (SUB-ONCE (QUOTE X)
[SETQ GTEMP19 (COND
((FMEMB (CAR RAN2)
DOM1)
(CAR RAN2))
((IS-ONE-OF (CAR RAN2)
DOM1))
((SETQ SCHK (ONE-ISA DOM1 (CAR RAN2]
DOM1
(* Notie that we really should be able to subst X for any suitable member of DOM1, regardless of
position. Sometimes, this would mean suggesting that new Beings be created.)
)
(FUNCTION (LAMBDA (Z)
(COND
((EQ Z (QUOTE X))
(QUOTE X))
(T (SETQ GTEMP20 (ADD1 GTEMP20))
(CAR (FNTH BA-LIST GTEMP20]
(AND (SETQ GTEMP7 (ALL-BUT-LAST (CADR SAPL)))
[OR (NEQ (LENGTH GTEMP7)
(LENGTH (INTERSECTION GTEMP7 GTEMP7)))
(SOME GTEMP7 (FUNCTION (LAMBDA (X)
(IS-ONE-OF X (CDR (FMEMB X GTEMP7]
[ADD-CANDS (LIST (LIST CS-INT (QUOTE APPLYB)
(Q COALESCE)
(Q ALGS)
(KWOTE CS-B]
(CPRIN1 7 "Later it probably will be interesting to coalesce the D-R of " F12 CRLF))
[SETQ PGM1 (LIST (QUOTE PROG)
(LIST (QUOTE X))
[LIST (QUOTE SETQ)
(QUOTE X)
(NCONC (LIST (QUOTE APPLYB)
(KWOTE F2)
(Q ALGS))
(FIRSTN (LENGTH DOM2)
(LIST (QUOTE BA1)
(QUOTE BA2)
(QUOTE BA3]
(COND
(SCHK (LIST (QUOTE AND)
(LIST (QUOTE ARG-CHECK)
(QUOTE X)
(KWOTE SCHK))
SAPL))
(T SAPL]
(SETQ DOM3 (REM-ONCE GTEMP19 DOM1))
(LIST (LIST (QUOTE OSET)
(APPEND DOM2 DOM3 RAN1))
PGM1])
(CPRIN1
[LAMBDA CPARG
(AND (IGREATERP VERBOSITY (ARG CPARG 1))
(FOR CPI FROM 2 TO CPARG DO (PRIN1 (ARG CPARG CPI])
(CREATEB
[LAMBDA (B)
(COND
((IS-CON B))
(T (ATTACH B CONCEPTS)
(PUTHASH B 1 HCON)
(SETQ FIXEDCONS (UNION (LIST B)
FIXEDCONS)) (* XEQ-CLEAN B)
(PUTD B (COPY TRIVB])
(DE-THRESH
[LAMBDA NIL
(SETQ DO-THRESH (IQUOTIENT (ITIMES DO-THRESH 2)
3))
(CPRIN1 7 " Do-Thresh reduced to " DO-THRESH " ")
DO-THRESH])
(DECRB
[LAMBDA (B P X)
(AND X (DREMOVE X (GETB B P])
(DEFB
[LAMBDA (B)
[MAPC XS-PARTS (FUNCTION (LAMBDA (XP BP)
(COND
((GETB B XP)
(SETQ BP (GLUEE B XP))
(OR (ASSOC XP (BPFS B))
(ATTACH (LIST XP (CONS BP (GETARGS XP)))
(BPFS B)))
(PUTD BP (LIST (QUOTE LAMBDA)
(GETARGS XP)
(LIST (QUOTE SELF-COMPILE)
BP
(FGETB B XP]
(AND (GETB B (QUOTE ALGS))
(NULL (GETB B (QUOTE INV)))
(ATTACH [LIST (QUOTE INV)
(CONS (GLUEE B (QUOTE ALGS))
(GETARGS (QUOTE ALGS]
(BPFS B])
(DEFP
[LAMBDA (F)
(PUTD F (LIST (QUOTE NLAMBDA)
(CONS (QUOTE B)
(AND (FMEMB F XEQ-PARTS)
(GETARGS F)))
(COND
[(FMEMB F SUF-PARTS)
(PUT F (QUOTE INFO)
(QUOTE EVAL))
(CONS (QUOTE PSUF)
(CONS (KWOTE F)
(CONS (QUOTE B)
(GETARGS F]
[(FMEMB F OR-PARTS)
(CONS (QUOTE POR)
(CONS (KWOTE F)
(CONS (QUOTE B)
(GETARGS F]
[(FMEMB F XEQ-PARTS)
(PUT F (QUOTE INFO)
(QUOTE EVAL))
(CONS (QUOTE PXEQ)
(CONS (KWOTE F)
(CONS (QUOTE B)
(GETARGS F]
(T (LIST (QUOTE PGET)
(KWOTE F)
(QUOTE B])
(DIE
[LAMBDA (MES)
(CPRIN1 -1 CRLF CRLF "*********** AM FATAL COLLAPSE *********** " CRLF MES CRLF CRLF)
(HELP])
(DOTPROD
[LAMBDA (V1 V2)
(OR [AND V1 V2 (PLUS (TIMES (EVAL (CAR V1))
(EVAL (CAR V2)))
(DOTPROD (CDR V1)
(CDR V2]
0])
(DRAND-PERMUTE
[LAMBDA (L L1)
(AND (SETQ L1 (RAND-MEMB L))
(CONS L1 (DRAND-PERMUTE (DREMOVE L1 L])
(DWIMUSERFN
[LAMBDA (X1 X3)
(AND (MATCH (UNPACK FAULTX) WITH (X1←--
'- 'E '- X3←--))
(GETHASH (SETQ X1 (PACK X1))
HCON)
(FMEMB (SETQ X3 (PACK X3))
XEQ-PARTS)
[DEFINE (LIST (LIST FAULTX (LIST (QUOTE LAMBDA)
(GETARGS X3)
(LIST (QUOTE SELF-COMPILE)
X1
(GETB X1 X3]
(CONS FAULTX FAULTARGS])
(ENSURE
[LAMBDA (B P)
(OR (AND (OR (MEMB P FACETS)
(MEMB [PACK (DREVERSE (CDR (DREVERSE (UNPACK P]
FACETS))
(OR (GETHASH B HCON)
(CREATEB B))
(OR (GETB B P)
(INIT-PART B P)))
(CPRIN1 1 "*** WARNING: B,P are not accessable: " B COMMA P CRLF])
(ENSURE-TOP
[LAMBDA NIL
(OR (AND [COND
((ATOM CS-P)
(MEMB CS-P FACETS))
([MATCH CS-P WITH ('QUOTE &@(LAMBDA (Z)
(MEMB Z FACETS]
(SETQ CS-P (CADR CS-P]
[COND
((ATOM CS-B)
(CREATEB CS-B))
((MATCH CS-B WITH ('QUOTE &@CREATEB))
(SETQ CS-B (CADR CS-B]
(MEMB CS-OP TOP-ACTS))
(CPRIN1 1 "*** WARNING: CS OP,B,P aren't meaningful (yet):" CRLF CS-OP COMMA CS-B COMMA CS-P])
(EVERY2
[LAMBDA (X Y F)
(OR (NULL X)
(NULL Y)
(AND (APPLY* F (CAR X)
(CAR Y))
(EVERY2 (CDR X)
(CDR Y)
F])
(EXA
[LAMBDA (Z V A1 A2)
(COND
((NLISTP Z)
Z)
((AND (MATCH Z WITH ('VECTOR A1←&
('APPLYB & & A2←$)
V←&))
(EQUAL A1 A2))
V)
(Z])
(FAN
[LAMBDA (MSET MPAR MB1)
(CAR (SORT (MAPCAR MSET (FUNCTION (LAMBDA (MS1)
(APPLYB MS1 MPAR MB1])
(FIL-ACEX
[LAMBDA (X)
(LIST (QUOTE ANY1SAT)
(LIST (COND
((ISA X (QUOTE ACTIVE))
(QUOTE ACEX))
(T (QUOTE EXS)))
(KWOTE X])
(FIL-EX1
[LAMBDA (BA1 BA2 NEWB)
(LIST (LIST (LIST (QUOTE NULL)
BA1)
(LIST (QUOTE APPLYB)
(KWOTE NEWB)
(Q ALGS)
(NCONC1 (FIL-ACEX (CAR BAL1))
(SUBST (QUOTE X)
(QUOTE BA1)
GTEMP9])
(FIL-EX2
[LAMBDA (BA1 BA2 NEWB)
(LIST [LIST (LIST (QUOTE AND)
(LIST (QUOTE NULL)
(QUOTE BA1))
(LIST (QUOTE NULL)
(QUOTE BA2)))
[LIST (QUOTE SETQ)
(QUOTE GTEMP23)
(NCONC1 (FIL-ACEX (CAR BAL1))
(SUBST (QUOTE X)
(QUOTE BA1)
(SETQ TMP2 (SUBSET-INVOLVING-ONLY GTEMP9 (QUOTE BA1]
(LIST (QUOTE COND)
(LIST [LIST (QUOTE SETQ)
(QUOTE GTEMP24)
(NCONC1 (FIL-ACEX (CADR BAL1))
(CONS (QUOTE AND)
(SUBST (QUOTE X)
(QUOTE BA2)
(SUBST (QUOTE GTEMP23)
(QUOTE BA1)
(SET-DIFF GTEMP9 TMP2]
(AQ-LIST CS-B GTEMP23 GTEMP24 BA3 BA4))
(LIST T (LIST (QUOTE APPLYB)
(KWOTE NEWB)
(Q ALGS]
(LIST (LIST (QUOTE AND)
(QUOTE BA1)
(LIST (QUOTE NULL)
(QUOTE BA2)))
(LIST (QUOTE AND)
[LIST (QUOTE SETQ)
(QUOTE GTEMP24)
(NCONC1 (FIL-ACEX (CADR BAL1))
(CONS (QUOTE AND)
(SUBST (QUOTE X)
(QUOTE BA2)
GTEMP9]
(AQ-LIST CS-B BA1 GTEMP24 BA3 BA4)))
(LIST (LIST (QUOTE AND)
(LIST (QUOTE NULL)
(QUOTE BA1))
(QUOTE BA2))
(LIST (QUOTE AND)
[LIST (QUOTE SETQ)
(QUOTE GTEMP23)
(NCONC1 (FIL-ACEX (CAR BAL1))
(CONS (QUOTE AND)
(SUBST (QUOTE X)
(QUOTE BA1)
GTEMP9]
(AQ-LIST CS-B GTEMP23 BA2 BA3 BA4)))
(LIST (LIST (QUOTE AND)
(QUOTE BA1)
(QUOTE BA2))
(CONS (QUOTE AND)
(APPEND GTEMP9 (LIST (AQ-LIST CS-B BA1 BA2 BA3 BA4])
(FIL-STRUC-P
[LAMBDA (P)
(MAPCONC (REMOVE CS-B (KINDS-OF (QUOTE STRUCTURE)))
(FUNCTION (LAMBDA (S TKNT)
(SETQ TKNT (IPLUS (COND
[(GETB CS-B (QUOTE WORTH))
(ITIMES 100 (CAR (GETB CS-B (QUOTE WORTH]
(T 1000))
(CLOCK 2)))
(MAPCONC (GETB S P)
(FUNCTION (LAMBDA (X1)
(AND (ILESSP (CLOCK 2)
TKNT)
(APPLY* (QUOTE VIEW)
CS-B X1 S])
(FIND-NEW-CANDS
[LAMBDA NIL
(CPRIN1 6 " Must find new CANDs" CRLF)
(SETQ INTHRESH (IN-FACTOR DO-THRESH))
(ADD-CANDS (MAPCONC CONCEPTS (QUOTE UNFORGETTABLE])
(FIRSTN
[LAMBDA (N L)
(LDIFF L (FNTH L (ADD1 N])
(FLATTEN
[LAMBDA (L)
(COND
((NLISTP L)
(LIST L))
((MAPCONC L (QUOTE FLATTEN])
(FOU
[LAMBDA (C)
(CAADAR (FNTH G-IF (CADR C])
(FOU1
[LAMBDA (C)
(CAR (FNTH G-IF (CADR C])
(FRAC-INCLU
[LAMBDA (B1 B2)
(COND
((EQ B1 B2)
100)
((ISA B1 B2)
99)
((ISA B2 B1)
50)
(T (* NOTICE HOW CRUDE THIS IS.
IMPROVE IT!!)
0])
(FSET-NTH
[LAMBDA (S N X)
(CAR (FRPLACA (FNTH S N)
X])
(GATH
[LAMBDA (B GENB GENP)
(* the old version was: COND ((SETQ GENB (CAR (APPLYB B
(QUOTE UP) (QUOTE FILLIN)))) (COND ((GETHASH (SETQ GENP
(GLUE GENB GATH-PART)) HCON) (ATTACH GENP GPGM))) (COND
((GETHASH (SETQ GENP (GLUE GENB (QUOTE ANYP))) HCON)
(ATTACH GENP GPGM))) (GATH GENB)))
(RIPPLE B GATH-PART (QUOTE GENL])
(GCB
[LAMBDA (N)
[MAPC ONCE-LIST (FUNCTION (LAMBDA (C)
(SETB (CAR C)
(CDR C)
(REMOVE JTRASH (GETB (CAR C)
(CDR C]
(SETQ ONCE-LIST INIT-ONCE-LIST)
(FOR GCX IN (SORT (COPY CONCEPTS)
(QUOTE GET-TIME))
AS GCI FROM 1 TO N DO (SWAPB GCX])
(GEN-FNAME
[LAMBDA (A B)
(PACK (LIST (QUOTE F)
A
(QUOTE -)
B
(QUOTE -)
(SETQ F-COUNTER (ADD1 F-COUNTER])
(GET-TIME
[LAMBDA (B)
(GETU B (QUOTE TIME])
(GETARGS
[LAMBDA (P)
(GETP P (QUOTE ARGS])
(GETB
[LAMBDA (B P)
(UNDO-INIT P (GETP B P])
(GETB-P
[LAMBDA (B)
(GETB B P])
(GETB-P-C
[LAMBDA (B)
(COPY (GETB B P])
(GETBQ
[NLAMBDA (B P)
(GETP B P])
(GETU
[LAMBDA (B PROP)
(GET (GETTOPVAL B)
PROP])
(GEXADD
[LAMBDA (X)
(SETQ GEXISTING (UNION GEXISTING X))
X])
(GEXEC
[LAMBDA (GB)
(APPLYB GB GPNAME])
(GINIT
[LAMBDA (P)
(APPEND (GETP P (QUOTE INIT])
(GLUE
[LAMBDA (B P) (* A more sophisticated scheme can be
implemented: e.g., using HASHing)
(PACK (LIST B (QUOTE -)
P])
(GLUEC
[LAMBDA (B1 B2)
(PACK (LIST (QUOTE COMPOSE-)
B1
(QUOTE &)
B2])
(GLUEE
[LAMBDA (B P) (* A more sophisticated scheme can be
implemented: e.g., using HASHing)
(PACK (LIST B (QUOTE -E-)
P])
(GPGM-PRIN
[LAMBDA (GFN GNAM)
(COND
[(CDR GPGM)
(DREMOVE T GPGM)
(CPRIN1 9 " The (G)pgm to " GNAM CRLF CS-B COMMA CS-P " is:" CRLF GPGM)
(SETQ GPNAME (GETHASH GNAM SUF1))
(MAPC GPGM GFN)
(SETQ GPNAME (GETHASH GNAM SUF2))
(MAPC (DREVERSE GPGM)
GFN)
(ADD-CANDS (LIST (LIST 400 (QUOTE RE-JUDGE)
(LIST CS-B CS-P]
((CPRIN1 3 CRLF "***** WARNING: UNABLE TO FIND ANY INFO RELE TO " GNAM " THE " CS-P " PART OF " CS-B CRLF])
(GTRANSFER
[LAMBDA (GEX NEWGP)
(DECRB CS-B CS-P GEX)
(AND (ENSURE CS-B (SETQ GTEMP4 (GLUE CS-P NEWGP)))
(INCRB CS-B GTEMP4 GEX])
(HANDLE-I
[LAMBDA NIL
(PRIN1 "Interest "])
(HANDLE-I-INTERRUPT
[LAMBDA (ITMP)
(CLEARBUF T T)
(PRIN1 "
?: ")
(SELECTQ (READ1CHAR)
((I i)
(HANDLE-I))
((Q q)
(CPRIN1 0 "Quitting. Resuming execution " CRLF))
((N n)
(HANDLE-N))
((E e)
(PRIN1 "Evaluate: ")
(PRINT (EVAL (READ)))
(HANDLE-I-INTERRUPT))
(PROGN (TERPRI)
(PRIN1 "No, no! Allowable commands are: Interest, Name, Eval.")
(HANDLE-I-INTERRUPT])
(HANDLE-N
[LAMBDA NIL
(PRIN1 "NAME "])
(IN-FACTOR
[LAMBDA (N)
(IQUOTIENT N 5])
(INCRB
[LAMBDA (B P X I)
(COND
((NULL X)
NIL)
[(SETQ I (INIT-PART B P))
(COND
((MEMBER X (GETB B P))
I)
((NCONC1 I X]
((SETB B P (NCONC1 (GINIT P)
X])
(INIT-PART
[LAMBDA (B P)
(OR (GETP B P)
(SETB B P (COPY (GINIT P])
(INSTAN-1D
[LAMBDA (D BASE REC PAT P SFN DTYP DBOD CR CC CARGS CB CBX TEXS SUCC-TEXS)
(MATCH D WITH (SFN←&
DTYP←$
DBOD←&))
(SELECTQ (CAR DTYP)
[RECURSIVE (AND [OR (MATCH DBOD WITH ('OR BASE←$
REC←&))
(MATCH DBOD WITH ('COND BASE←$
(REC←&)))
(MATCH DBOD WITH ('COND BASE←$
('T REC←$]
(NCONC (INSTAN-BASE BASE)
(INSTAN-REC REC]
[NONRECURSIVE (OR (AND (EQUAL (CAR DBOD)
(QUOTE AND))
(SIMULT-SATISFY (CDR DBOD)))
(AND (MATCH DBOD WITH ('MATCH 'BA1 'WITH PAT←&))
(INSTAN-PAT PAT))
(AND (MATCH DBOD WITH (&@[LAMBDA (Z)
(OR (EQ Z (QUOTE EQ))
(EQ Z (QUOTE EQUAL]
CR←&
CC←&))
(CR-INVERT CR CC]
[TRANSFORM (OR (AND (MATCH DBOD WITH ('AND CC←$
('APPLYB ('QUOTE CB←&@IS-CON)
('QUOTE 'DEFN)
CARGS←$)))
(COND
((ISA CS-B (QUOTE ACTIVE))
(INSTAN-ACT-TRANS CB CC))
((MATCH CC WITH (('SOME CBX←&
REC←&)))
[SETQ SUCC-TEXS (SUBSET (SETQ TEXS (APPLY* (QUOTE EXS)
CB))
(FUNCTION (LAMBDA (BA1)
(EVAL (CAR CC]
(APPENDB CS-B (QUOTE EXS-NOT-BDY)
(SET-DIFFERENCE TEXS SUCC-TEXS))
SUCC-TEXS)))
(AND (MATCH DBOD WITH ('APPLYB ('QUOTE CB←&@IS-CON)
('QUOTE 'ALGS)
CARGS←$))
(INSTAN-TRANSF DBOD]
(QUASIRECURSIVE NIL)
(APPLICATION (* I THINK THIS IS JUST EVAL OF THE
FINAL MEMBER OF TYPE,...)
NIL)
(PC (* PRED. CALC. MUST TRANSFORM
(BAJ X) INTO (APPLYB BAJ ALGS
(TRANSFORM X)))
NIL)
(BRANCH NIL)
(IMPLICIT NIL)
(CPRIN1 0 CRLF "******* WARNING: NOT A KNOWN TYPE OF DEFN: " D CRLF " EVAL OF CADR OF THIS IS: " P CRLF
"BACK-TRACING: " CRLF (AM-BT)
CRLF])
(INSTAN-1I
[LAMBDA (I)
(GEXADD (ERRORSET I])
(INSTAN-1S
[LAMBDA (S)
NIL])
(INSTAN-ACT-TRANS
[LAMBDA (CB CC TMPD LTIME LOSE)
(* This is where all the thinking goes. Where do i get the right stuff to put in...
do i go from the reduced-to BEING, and check to see if it meets the new requirements, etc.)
(AND (EVERY (ANY1OFE (GETB CS-B (QUOTE D-R)))
(QUOTE ACEX))
(SETQ LTIME (ITIMES -1 (CLOCK 2)))
(PROG NIL
L5 [MAP2C BA-LIST (ANY1OFE (GETB CS-B (QUOTE D-R)))
(FUNCTION (LAMBDA (BA BB)
(SET BA (RAND-MEMB (ACEX BB]
(COND
([AND (EVERY CC (QUOTE EVAL))
(SETQ TMPD (SOMEE (GETB CB (QUOTE DEFN))
(QUOTE INSTAN-1D]
(CPRIN1 9 " In instantiating the definition of " CS-B ",
which actually is just that of " CB ", plus " (LENGTH CC)
" new
constraints, AM has in fact found an example.")
(CPRIN1 10 " in " (QUOTIENT (PLUS LTIME (CLOCK 2))
1000.0)
" seconds." CRLF " The example is: " TMPD)
(CPRIN1 9 CRLF)
(RETURN TMPD))
((MINUSP (IPLUS (CLOCK 2)
LTIME -100000))
(GO L5))
(T (CPRIN1 9 " Sorry, AM ran out of time, trying to find an example of" CRLF CS-B
", which by the way reduces to " CB ", plus " (LENGTH CC)
" new conditions." CRLF)
(RETURN NIL])
(INSTAN-BASE
[LAMBDA (BASE BEX)
(SOMEE BASE (FUNCTION (LAMBDA (BASE1)
(AND (LISTP BASE1)
(NULL (CDR BASE1))
(SETQ BASE1 (CAR BASE1)))
(AND (MATCH BASE1 WITH (&@[LAMBDA (Z)
(OR (EQ Z (QUOTE EQ))
(EQ Z (QUOTE EQUAL]
'BA1 BEX←&))
(ERRORSET BEX])
(INSTAN-D
[LAMBDA (DE)
(MAPCONC DE (QUOTE INSTAN-1D])
(INSTAN-I
[LAMBDA (IN)
(MAPCONC (CDR IN)
(QUOTE INSTAN-1I])
(INSTAN-PAT
[LAMBDA (PAT1)
(SETQ PAT1 (COPY PAT1))
(ATTACH (QUOTE LIST)
PAT1)
(DSUBST (LIST (QUOTE RAND-THING))
(QUOTE &)
PAT1)
(SETQ PAT1 (LSUBST (LIST (LIST (QUOTE RAND-THING))
(LIST (QUOTE RAND-THING)))
(QUOTE --)
PAT1))
(SETQ PAT1 (LSUBST (LIST (LIST (QUOTE RAND-THING))
(LIST (QUOTE RAND-THING)))
(QUOTE $)
PAT1)) (* This should be made recursive, on
CAR, it should call itself if LISTP,
else check unpack for ←)
(GEXADD (ERRORSET PAT1])
(INSTAN-REC
[LAMBDA (REC1 DPROC BOP)
(SETQ REC1 (COPY REC1))
(AND (EQ (CAR REC1)
(QUOTE APPLYB))
(EQ (EVAL (CADDR REC1))
(QUOTE DEFN))
(OR (EQ (EVAL (CADR REC1))
CS-B)
(CPRIN1 2 CRLF "Warning from INSTAN-REC: The concept " (CADR REC1)
", which = "
(EVAL (CADR REC1))
" is NOT equal to CS-B, which = " CS-B CRLF)
T)
(SETQ DPROC (CADDDR REC1))
(GEXADD (OR [AND (EQ (CAR DPROC)
(QUOTE APPLYB))
(EQ (EVAL (CADDR DPROC))
(QUOTE ALGS))
(SETQ BOP (EVAL (CADR DPROC)))
(GETHASH BOP HCON)
(LIST (APPLYB BOP (OR (AND (APPLYB (QUOTE CONSTRUCTIVE)
(QUOTE DEFN)
BOP)
'ALGS)
(QUOTE INV))
(CADDDR DPROC)
(CAR (CDDDDR DPROC))
(CADR (CDDDDR DPROC]
(ERRORSET DPROC])
(INSTAN-S
[LAMBDA (SP)
(MAPCONC (CDR SP)
(QUOTE INSTAN-1S])
(INSTAN-TRANSF
[LAMBDA (DBOD CARGS CB TMPD LOSE LTIME)
(AND [EVERY [ALL-BUT-LAST (ANY1OFE (GETB CS-B (QUOTE D-R]
(FUNCTION (LAMBDA (BB)
(OR (GETB BB (QUOTE EXS))
(APPLY* (QUOTE EXS)
BB)
(PROGN [ADD-CANDS (LIST (LIST (AVG2 100 CS-INT)
(QUOTE FILLIN)
BB
(QUOTE EXS]
(SETQ LOSE T)
NIL]
(SETQ LTIME (ITIMES -1 (CLOCK 2)))
(PROG NIL
L5 [MAP2C BA-LIST [ALL-BUT-LAST (ANY1OFE (GETB CS-B (QUOTE D-R]
(FUNCTION (LAMBDA (BA BB)
(SET BA (RAND-MEMB (XTR-AC-EX (RUN-COMM-IF-MUST (OR (GETB BB (QUOTE EXS))
(APPLY* (QUOTE EXS)
BB]
(COND
((AND (EVERY2 (MAPCAR CARGS (QUOTE EVAL))
[ALL-BUT-LAST (ANY1OFE (GETB CB (QUOTE D-R]
(QUOTE ISA))
(SETQ TMPD (EVAL DBOD)))
(CPRIN1 9 " In instantiating the definition of " CS-B ",
which twists into that of " CB ", AM has in fact found an example ")
(CPRIN1 10 " in " (QUOTIENT (PLUS LTIME (CLOCK 2))
1000.0)
" seconds." CRLF " The example is: " TMPD)
(CPRIN1 9 CRLF)
(RETURN TMPD))
((MINUSP (IPLUS (CLOCK 2)
LTIME -100000))
(GO L5))
(T (CPRIN1 9 " Sorry, AM ran out of time, trying to find an example of" CRLF CS-B
", which by the way reduces to " CB CRLF)
(RETURN NIL])
(INT-ENUF
[LAMBDA (S P IM CM)
(SETQ GREM NIL)
(AND (SETQ GIFN (SELECTQ P
(DEFN (QUOTE IDEF))
(QUOTE IVAL)))
(SETQ NEW-ILEV 200)
(SETQ G-IF (IFEATURES S))
(SETQ IM (IMAT S))
(PROGN [MAPC IM (FUNCTION (LAMBDA (CYC TV1)
(SETQ TV1 (MAXI CYC (QUOTE SORV)))
(COND
[(IGREATERP (CAR TV1)
INT-THRESH)
(SETQ NEW-ILEV (PLUS NEW-ILEV (CAR TV1)))
(SETQ CM (NCONC1 CM (FOU TV1]
(T (SETQ GREM (NCONC1 GREM (FOU1 TV1]
[SETQ NEW-ILEV (IQUOTIENT NEW-ILEV (ADD1 (LENGTH CM]
CM])
(INT-PREDS
[LAMBDA NIL (* This can be made fancier later --
E.G., cut off those with wrong no.
of args, or with lo enuf int)
GINTPREDS])
(IS-CON
[LAMBDA (B)
(GETHASH B HCON])
(IS-CON-L
[LAMBDA (B)
(AND (GETHASH B HCON)
(LIST B])
(IS-ONE-OF
[LAMBDA (X XSET)
(AND X XSET (CAR (OR (FMEMB X XSET)
(SOME (RIPPLE X (QUOTE GENL))
(FUNCTION (LAMBDA (Z)
(FMEMB Z XSET])
(ISA
[LAMBDA (BNAME BTYPE)
(COND
((EQ BNAME BTYPE))
(BNAME (SOME (GETB BNAME (QUOTE GENL))
(FUNCTION (LAMBDA (X1)
(ISA X1 BTYPE])
(JUST-ONCE
[NLAMBDA (X X1)
(COND
((SETQ X1 (EVAL X))
(FRPLACA X (QUOTE COND))
(FRPLACD X NIL)
X1])
(KINDS-OF
[LAMBDA (K)
(OR (APPLY* (QUOTE SPEC)
K)
(SUBSET CONCEPTS (FUNCTION (LAMBDA (KC)
(FMEMB K (APPLYB KC (QUOTE GENL])
(LARGER
[LAMBDA (A B)
(COND
((ILESSP A B)
B)
(A])
(LESS-INT
[LAMBDA (A B)
(ILESSP (CAR A)
(CAR B])
(LRU-TAG
[LAMBDA (B)
(PUTU B (QUOTE TIME)
(IQUOTIENT (CLOCK 2)
10000])
(M2
[LAMBDA NIL
(SETQ CAND (LIST 0))
(MAPC CANDS (FUNCTION (LAMBDA (Z)
(OR (ILESSP (CAR Z)
(CAR CAND))
(SETQ CAND Z])
(MAPAPPEND
[LAMBDA (XSET F)
(APPLY (QUOTE APPEND)
(MAPCAR XSET F])
(MAX
[LAMBDA (MSET MPAR)
(COND
[MSET (CAR (SORT (MAPCAR MSET MPAR]
(T -1])
(MAX1
[LAMBDA (MSET MPAR MB1)
(CAR (SORT (MAPCAR MSET (FUNCTION (LAMBDA (MS1)
(APPLYB MB1 MPAR MS1])
(MAX2
[LAMBDA (X1 X2 F MVAL MCAN)
(SETQ MVAL -1)
[MAP2C X1 X2 (FUNCTION (LAMBDA (Z1 Z2 TMV)
(AND (SETQ TMV (APPLY* F Z1 Z2))
(ILESSP MVAL TMV)
(SETQ MVAL TMV)
(SETQ MCAN (LIST Z1 Z2 TMV]
(CONS MVAL MCAN])
(MAXI
[LAMBDA (MSET MFN)
(PROG (TV MC (MVAL -1000))
L1 [COND
((NULL MSET)
(RETURN (LIST MVAL MC)))
((IGREATERP (SETQ TV (APPLY* MFN (CAR MSET)))
MVAL)
(SETQ MVAL TV)
(SETQ MC (CAR MSET]
(SETQ MSET (CDR MSET))
(GO L1])
(MIN2
[LAMBDA (X1 X2 F MVAL MCAN)
(SETQ MVAL 1000)
[MAP2C X1 X2 (FUNCTION (LAMBDA (Z1 Z2 TMV)
(AND (SETQ TMV (APPLY* F Z1 Z2))
(ILESSP TMV MVAL)
(SETQ MVAL TMV)
(SETQ MCAN (LIST Z1 Z2 TMV]
MCAN])
(MKSWAPP
[LAMBDA (FNAME CDEF)
(NOT (MEMB FNAME (CDAR TOP4COMS])
(MORE-GENERAL
[LAMBDA (B1 B2)
(COND
((MEMB B1 (RIPPLE B2 (QUOTE GENL)))
B2)
((MEMB B2 (RIPPLE B1 (QUOTE GENL)))
B1)
(T NIL])
(MORE-INT
[LAMBDA (A B)
(IGREATERP (CAR A)
(CAR B])
(MORE-SPECIFIC
[LAMBDA (B1 B2)
(COND
((MEMB B1 (RIPPLE B2 (QUOTE GENL)))
B1)
((MEMB B2 (RIPPLE B1 (QUOTE GENL)))
B2)
(T NIL])
(NCONCB
[LAMBDA (B P X)
(AND X (SETB B P (SELF-INT (APPEND (INIT-PART B P)
X])
(NO-COMMEN
[LAMBDA (X)
(OR (NLISTP X)
(NEQ (CAR X)
(QUOTE COMMENT])
(ONE-ISA
[LAMBDA (XSET X)
(AND X (CAR (SOME XSET (FUNCTION (LAMBDA (X1)
(ISA X1 X])
(ONLY-COMS
[LAMBDA (L)
(EVERY L (FUNCTION (LAMBDA (L1)
(EQ (CAR L1)
(QUOTE COMMENT])
(PGET
[LAMBDA (P B)
(MAPCONC (RIPPLE-SIMULT B (GETP P (QUOTE CENT)))
(QUOTE GETB-P-C])
(PICK-CAND
[LAMBDA NIL
(PROG NIL
P1 (M2)
(COND
((ILESSP (CAR CAND)
DO-THRESH)
(DE-THRESH)
(FIND-NEW-CANDS)
(GO P1)))
(CPRIN1 5 "New Cand = " CAND)
(COND
((SETQ CANDS (REMOVE CAND CANDS)))
((SETQ CANDS CAND-TAIL)))
(COND
((RECENTLY-TRIED CAND)
(CPRIN1 3 " Repeater Cand skipped " CRLF)
(AND (ZEROP DO-THRESH)
(DIE " DO-THRESH IDENTICALLY ZERO "))
(RPLACINT CAND (SETQ GTEMP1 (IQUOTIENT (CINT CAND)
6)))
(COND
((IGREATERP GTEMP1 INTHRESH)
(ATTACH CAND CANDS)
(ATTACH (QUOTE ONCE)
(RECENTLY-TRIED CAND))
(CPRIN1 3 "for now." CRLF))
(T (CPRIN1 3 "for the forseeable future." CRLF)))
(GO P1))
((AND (SETQ CS-OP (COP CAND))
(SETQ CS-B (CB CAND))
(SETQ CS-P (CP CAND))
(ENSURE-TOP))
(SETQ CS-INT (CINT CAND))
(SETQ CS-ACT (CACT CAND))
(SETQ GEXISTING (GETB CS-B CS-P))
(SETQ ORIG-EMP (NULL GEXISTING))
(RETURN CAND)))
(GO P1])
(POR
[LAMBDA (P B BA1 BA2 BA3 BA4 RS C1)
(SETQ C1 (GETP P (QUOTE CENT)))
(AND (SETQ RS (REVERSE (RIPPLE-SIMULT B C1)))
(INIT-PART B P)
(SOME-EBP RS P BA1 BA2 BA3 BA4])
(PRUNABLE
[LAMBDA (C)
(NOT (ILESSP INTHRESH (CINT C])
(PRUNE
[LAMBDA (N)
(SETQ CANDS (SUBSET CANDS (QUOTE UNPRUNABLE])
(PSUF
[LAMBDA (P B BA1 BA2 BA3 BA4 RS C1 PP)
(SETQ C1 (GETP P (QUOTE CENT)))
(AND (SETQ RS (RIPPLE-SIMULT B C1))
(SETQ PP P)
(OR (AND BA1 (FMEMB P STRATEGY-PARTS)
(FMEMB BA1 FACETS)
(SETQ PP BA1)
[SETQ RS (MAPCONC RS (FUNCTION (LAMBDA (R)
(IS-CON-L (GLUE R BA1]
[NCONC RS (MAPCONC RS (FUNCTION (LAMBDA (R)
(RIPPLE-SIMULT R C1]
(SETQ RS (INTERSECTION RS RS)))
T)
(SETQ GEXISTING (INIT-PART B PP))
(NCONCB B PP (NCONC (SETQ P (GETHASH P SUF1))
(MAPCONC RS (QUOTE APPLYB-P))
(SETQ P (GETHASH P SWSUF))
(MAPCONC (DREVERSE RS)
(QUOTE APPLYB-P])
(PUTB
[LAMBDA (B P Q)
(COND
(Q (PUT B P Q))
(T (REMPROP B P])
(PUTU
[LAMBDA (B PROP PVAL)
(COND
((CAR (ERRORSET B))
(PUTL (EVAL B)
PROP PVAL))
(T (SET B (LIST PROP PVAL])
(PXEQ
[LAMBDA (P B BA1 BA2 BA3 BA4 RS C1 PP)
(SETQ C1 (GETP P (QUOTE CENT)))
(AND (SETQ RS (RIPPLE-SIMULT B C1))
(SETQ PP P)
(OR (AND BA1 (FMEMB P STRATEGY-PARTS)
(FMEMB BA1 FACETS)
(SETQ PP BA1)
[SETQ RS (MAPCONC RS (FUNCTION (LAMBDA (R)
(IS-CON-L (GLUE R BA1]
[NCONC RS (MAPCONC RS (FUNCTION (LAMBDA (R)
(RIPPLE-SIMULT R C1]
(SETQ RS (INTERSECTION RS RS)))
T)
(SETQ GEXISTING (INIT-PART B PP))
(NCONCB B PP (MAPCONC RS (QUOTE APPLYB-P])
(Q
[NLAMBDA (X)
(LIST (QUOTE QUOTE)
X])
(RAND-CON
[LAMBDA NIL
(SETQ RANC (GETHASH RANC CIRC])
(RAND-MEMB
[LAMBDA (S)
(AND (LISTP S)
(CAR (FNTH S (RAND 1 (LENGTH S])
(RAND-OBJ
[LAMBDA NIL
(CAR (OR (SETQ OBJX (CDR OBJX))
(SETQ OBJX (EXS OBJECT])
(RAND-PERMUTE
[LAMBDA (L L1 M)
(ANY1OF [AND (SETQ L (COPY L))
(CONS (SETQ L1 (RAND-MEMB L))
(RAND-PERMUTE (DREMOVE L1 L]
(PROGN (SETQ M (LIST T))
[MAPC L (FUNCTION (LAMBDA (L1)
(ATTACH L1 (FNTH M (RAND 1 (LENGTH M]
(CDR (DREVERSE M])
(RAND-PRED
[LAMBDA NIL
(ZEROP (RAND 0 1])
(RAND-SUBSET
[LAMBDA (S)
(SUBSET S (QUOTE RAND-PRED])
(RAND-THING
[LAMBDA NIL
(APPLY (GETHASH RANF CIRC])
(RAND-USER
[LAMBDA NIL
(SETQ RANU (GETHASH RANU CIRC])
(RANDQMEMB
[LAMBDA (S)
(AND (LISTP S)
(KWOTE (CAR (FNTH S (RAND 1 (LENGTH S])
(RE-JUDGE
[NLAMBDA (RJ I1)
(CPRIN1 8 " SUPPOSED TO RE-JUDGE " RJ CRLF)
(AND [SETQ I1 (ERSETQ (APPLY* (CAR RJ)
(QUOTE C-INT)
(EVAL RJ]
(NUMBERP I1)
(IGREATERP I1 EX-THRESH)
(CREATEB RJ])
(READ-LOOP
[LAMBDA NIL
(PROG NIL
L11 (OR (READP)
(GO L11])
(READ1CHAR
[LAMBDA NIL
(READ-LOOP)
(CLEARBUF T T)
(SETQ GPEEK (SYSBUF T))
(SETQ GPEEK1 (GNC GPEEK))
(OR GPEEK1 (READ1CHAR)) (* OR (STREQUAL GPEEK "")
(BKSYSBUF GPEEK))
(* AND (SETQ GS (LINBUF T))
(BKLINBUF GS))
GPEEK1])
(RECENTLY-TRIED
[LAMBDA (C)
(SASSOC (CDR C)
PAST])
(RECTANGLE
[LAMBDA (X1 X2 Y1 Y2)
(COND
((IGREATERP X1 X2)
(SWITCH X1 X2)))
(COND
((IGREATERP Y1 Y2)
(SWITCH Y1 Y2)))
(FOR I1 FROM X1 TO X2 JOIN (FOR I2 FROM Y1 TO Y2 COLLECT (PACK (LIST (QUOTE R)
I1
(QUOTE -)
I2])
(REM-ONCE
[LAMBDA (X L)
(AND L (OR (AND (EQ (CAR L)
X)
(CDR L))
(CONS (CAR L)
(REM-ONCE X (CDR L])
(RIPPLE
[LAMBDA (ATYPE XTR-PART)
(PROG ((NEW (LIST ATYPE))
(OLD (LIST ATYPE)))
L1 [SETQ OLD (MAPCONC OLD (FUNCTION (LAMBDA (AL1)
(MAPCONC (GETB AL1 XTR-PART)
(QUOTE XTR-BEING]
(SETQ OLD (INTERSECTION OLD OLD))
(AND (EQ NEW (SETQ NEW (UNION OLD NEW)))
(RETURN NEW))
(GO L1])
(RIPPLE-SIMULT
[LAMBDA (ATYPE DIRS)
(COND
((CDR DIRS)
(PROG ((NEW (LIST ATYPE))
(OLD (LIST ATYPE)))
L1 [SETQ OLD (MAPCONC OLD (FUNCTION (LAMBDA (AL1)
(MAPCONC DIRS (FUNCTION (LAMBDA (XTR-PART)
(MAPCONC (GETB AL1 XTR-PART)
(QUOTE XTR-BEING]
(SETQ OLD (INTERSECTION OLD OLD))
(AND (EQ NEW (SETQ NEW (UNION OLD NEW)))
(RETURN NEW))
(GO L1)))
(DIRS (RIPPLE ATYPE (CAR DIRS)))
((LIST ATYPE])
(RIPPLE-UNTIL
[LAMBDA (ATYPE XTR-PART PRED)
(PROG ((NEW (LIST ATYPE))
(OLD (LIST ATYPE))
RVAL)
L1 [SETQ OLD (MAPCONC OLD (FUNCTION (LAMBDA (AL1)
(MAPCONC (GETB AL1 XTR-PART)
(QUOTE XTR-BEING]
(SETQ OLD (INTERSECTION OLD OLD))
(AND [SETQ RVAL (CAR (SOME OLD (LIST (QUOTE LAMBDA)
(LIST (QUOTE B))
PRED]
(RETURN RVAL))
(AND (EQ NEW (SETQ NEW (UNION OLD NEW)))
(RETURN NIL))
(GO L1])
(RIPPLE1
[LAMBDA (B4 P4 DIR RTEMP)
(COND
((LISTP B4)
(SETQ GXTR-PART P4)
[SOME (XTR-BEING B4)
(FUNCTION (LAMBDA (B5)
(SETQ RTEM2 (RIPPLE1 B5 P4 DIR]
RTEM2)
((GETHASH (SETQ RTEMP (GLUE B4 P4))
HCON)
RTEMP)
((GETHASH B4 HCON)
(RIPPLE1 (GETB B4 DIR)
P4 DIR])
(RMUL
[LAMBDA (AMUL IMUL JMUL)
(ITIMES IMUL (IQUOTIENT AMUL JMUL])
(RUN-COMM
[LAMBDA (L) (* This is basically superceded by
RUN-COMM-IF-MUST, qv.)
(PRIN1 " LOSE: Called run-comm. ")
(HANDLE-I-INTERRUPT])
(RUN-COMM-IF-MUST
[LAMBDA (L)
(COND
((NLISTP L)
L)
((SUBSET L (QUOTE NLISTP)))
[(MAPCAR [SUBSET L (FUNCTION (LAMBDA (X)
(EQ (CAR X)
(QUOTE OR-RUN:]
(FUNCTION (LAMBDA (Z)
(EVAL (CADR Z]
[(SUBSET L (FUNCTION (LAMBDA (X)
(NEQ (CAR X)
(QUOTE COMMENT]
(T (SETQ CS-FAIL T)
(ADD-CANDS (LIST (LIST CS-INT (QUOTE FILLIN)
Z
(QUOTE EXS))
(LIST (SUB1 CS-INT)
(QUOTE FILLIN)
CS-B CS-P)))
NIL])
(SAME-TYPE
[LAMBDA (B1 B2 BTYP)
(OR (AND (EQ B1 BTYP)
(EQ B2 B1)
B1)
(CADR (MEMB BTYP (COM-ANCES B1 B2])
(SATISFIES
[LAMBDA NIL NIL])
(SELF
[NLAMBDA (X)
(SET X X])
(SELF-COMPILE
[NLAMBDA (BP C AL)
(SETQ LAPFLG NIL)
(SETQ SVFLG NIL)
(SETQ STRF T)
(COMPILE1 BP (LIST (QUOTE LAMBDA)
(SETQ AL (ARGLIST BP))
C))
(EVAL (CONS BP AL])
(SELF-INT
[LAMBDA (S)
(INTERSECTION S S])
(SEQX
[LAMBDA (X1)
(OR (EQUAL X1 (CAR X))
(APPLYB (QUOTE STRUCTURE-EQUAL)
(QUOTE ALGS)
(APPEND (CAR X))
(APPEND X1])
(SET-DIFF
[LAMBDA (L M)
(ANY1OF (PROGN (SETQ L (APPEND L))
[MAPC M (FUNCTION (LAMBDA (M1)
(DREMOVE M1 L]
L)
(SUBSET L (FUNCTION (LAMBDA (L1)
(NOT (FMEMB L1 M])
(SET-DIFFERENCE
[LAMBDA (L M)
[MAPC M (FUNCTION (LAMBDA (M1)
(SETQ L (REMOVE M1 L]
L])
(SET-NTH
[LAMBDA (S N X I)
(COND
((FNTH S N)
(CAR (FRPLACA (FNTH S N)
X)))
((CDR S)
(FOR I FROM (ADD1 (LENGTH S)) TO N DO (NCONC1 S 0))
(CAR (FRPLACA (FNTH S N)
X])
(SETB
[LAMBDA (B P Q BP)
(AND (FMEMB P XEQ-PARTS)
Q
(PUTD (SETQ BP (GLUEE B P))
(LIST (QUOTE LAMBDA)
(GETARGS P)
(LIST (QUOTE SELF-COMPILE)
BP Q)))
(NOT (GETB B P))
(ATTACH (LIST P (CONS BP (GETARGS P)))
(BPFS B)))
(PUT B P Q])
(SETB-I
[LAMBDA (B P V)
(SETB B P (NCONC (GINIT P)
V])
(SETBQ
[NLAMBDA (B P Q)
(SETB B P (EVAL Q])
(SIMULT-SATISFY
[LAMBDA (GLIST BA BN SVAL TST)
[COND
[(MATCH GLIST WITH (('ISA BA←&
@[LAMBDA (Z)
(FMEMB Z BA-LIST]
('QUOTE BN←&@IS-CON))
(&@[LAMBDA (Z)
(NOT (FMEMB Z (LIST (QUOTE ISA)
(QUOTE ARE-EQUIV]
$)))
(SETQ TST (SUBST (QUOTE X)
BA
(CADR GLIST)))
(SETQ SVAL (OR (ANY1OF-SATISFYING (RUN-COMM-IF-MUST (XTR-AC-EX (APPLY* (QUOTE EXS-BDY)
BN)))
TST)
(ANY1OF-SATISFYING (RUN-COMM-IF-MUST (XTR-AC-EX (APPLY* (QUOTE EXS)
BN)))
TST]
(T (MAPC GLIST (FUNCTION (LAMBDA (G XPR BN2)
(COND
[[MATCH G WITH ('ISA BA←&@[LAMBDA (Z)
(FMEMB Z BA-LIST]
BN←&@(LAMBDA (Z)
(IS-CON (SETQ BN2 (CAR (ERRORSET Z]
(SETQ TMP8 (ACEX BN2))
(OR (AND (ERRORSET BA)
(ISA (EVAL BA)
BN2))
(SET BA (RAND-MEMB TMP8]
((MATCH G WITH ('ARE-EQUIV BA←&@[LAMBDA (Z)
(MATCH (UNPACK Z) WITH ('B 'A &@NUMBERP]
XPR←&))
(SETQ SVAL (SET BA (CAR (ERRORSET XPR]
(* Actually, to be truly "simult", we must re-check our earlier goals after each new one is
satisfied, and perhaps we should initially select the "hardest" one to satisfy first, etc,)
(COND
(SVAL (LIST SVAL])
(SMALLER
[LAMBDA (A B)
(COND
((ILESSP A B)
A)
(B])
(SOME-EBP
[LAMBDA (L P BA1 BA2 BA3 BA4)
(AND (LISTP L)
(OR (APPLYB (CAR L)
P BA1 BA2 BA3 BA4)
(SOME-EBP (CDR L)
P BA1 BA2 BA3 BA4])
(SOMEE
[LAMBDA (XSET FN)
(PROG (V)
L1 (COND
((SETQ V (APPLY* FN (CAR XSET)))
(RETURN V))
((SETQ XSET (CDR XSET))
(GO L1))
((RETURN NIL])
(SORD
[LAMBDA (X Y)
(AND (ALPHORDER X Y)
(OR (NLISTP X)
(NLISTP Y)
(EQUAL X Y)
(COND
((EQUAL (CAR X)
(CAR Y))
(SORD (CDR X)
(CDR Y)))
((SORD (CAR X)
(CAR Y])
(SORV
[LAMBDA (N)
(EVAL (APPLY* GIFN (IFEA (CAR (FNTH G-IF N])
(SSORT
[LAMBDA (Z)
(SORT (CDR Z)
(QUOTE SORD])
(START
[LAMBDA NIL
(SETQ PKNT 0)
(SETQ GCNT 0)
(SETQ ACEXPIRE 0)
(SETQ ACEX-OLDB NIL)
[MAPC BA-LIST (FUNCTION (LAMBDA (BA)
(SET BA NIL]
(SETQ DO-THRESH INIT-DOTHRESH)
(SETQ EX-THRESH INIT-EXTHRESH)
(SETQ INT-THRESH INIT-INT-THRESH)
(SETQ INTHRESH INIT-INTHRESH)
(SETQ CANDS (COPY INIT-CANDS))
(SETQ PAST (COPY INIT-PAST))
(CPRIN1 0 CRLF "Entering AM's main loop now." CRLF CRLF)
(TLOOP)
(CPRIN1 0 CRLF "Re-")
(START])
(STRUCTYP?
[LAMBDA (BA1 BA2 BA3)
[SETQ GTEMP3 (CAR (SOME (PROGN (SETQ GTEMP2 (SPEC STRUCTURE))
(OR (AND BA3 (FMEMB BA3 GTEMP2)
(CONS BA3 (REMOVE BA3 GTEMP2)))
GTEMP2))
(FUNCTION (LAMBDA (S)
(OR (FMEMB S (APPLY* (QUOTE UP)
BA2))
(FMEMB BA2 (APPLY* (QUOTE EXS)
S))
(APPLYB S (QUOTE DEFN)
BA2]
[OR (AND BA3 (NEQ BA3 GTEMP3)
BA2
(SETQ GTEMP1 (APPLY* (QUOTE VIEW)
BA3 BA2 GTEMP3))
(SETQ GTEMP3 BA3)
(SETQ BA2 GTEMP1))
(AND (NOT GTEMP3)
(SETQ GTEMP3 (OR BA3 (RAND-MEMB GTEMP2]
BA2])
(SUB-CANDS
[LAMBDA (SL)
[MAPC SL (FUNCTION (LAMBDA (S)
(SOME CANDS (FUNCTION (LAMBDA (C)
(AND (EQUAL (CACT C)
(CACT S))
(RPLACA C (IQUOTIENT (CINT C)
2] (* This is rather an inefficient way to
do this.)
CANDS])
(SUB-ONCE
[LAMBDA (X Y L)
(AND L (OR (AND (EQ (CAR L)
Y)
(CONS X (CDR L)))
(CONS (CAR L)
(SUB-ONCE X Y (CDR L])
(SUBSET-INVOLVING-ONLY
[LAMBDA (XSET V)
(SETQ V (REMOVE V BA-LIST2))
(CONS (QUOTE AND)
(SUBSET XSET (FUNCTION (LAMBDA (X)
(NOT (INTERSECTION V (FLATTEN X])
(SWAPB
[LAMBDA (B PFILE)
(COND
((GETU B (QUOTE FOUT)))
((PUTU B (QUOTE FOUT)
(LIST (SETQ PFILE (GETPROPERFILE))
(GETPROPERFILEPOS)))
(PRIN2 (GETPROPLIST B)
PFILE)))
(COND
((FMEMB B NOSWAP-CONCEPTS))
((SETPROPLIST B 0])
(SWGETB
[LAMBDA (B P F)
(LRU-TAG B)
(COND
((GET B P))
((ZEROP (GETPROPLIST B))
(SETQ F (GETU B (QUOTE FOUT)))
[COND
((ATOM F)
(LOADVARS (LIST (LIST (QUOTE (QUOTE PUTPROPS))
(KWOTE B)
(QUOTE $)))
F T))
(T (SETFILEPTR (CAR F)
(CADR F]
(SETQ B (READ (CAR F)))
(GET B P])
(SWITCH
[NLAMBDA (C1 C2 CTEMP)
(SETQ CTEMP (EVAL C1))
(SET C1 (EVAL C2))
(SET C2 CTEMP])
(SWSETB
[LAMBDA (B P Q BP)
(AND (FMEMB P XEQ-PARTS)
(PUTD (SETQ BP (GLUEE B P))
(LIST (QUOTE LAMBDA)
(GETARGS P)
(LIST (QUOTE SELF-COMPILE)
BP Q)))
(NOT (GETB B P))
(ATTACH (NCONC (LIST P (LIST BP))
(GETARGS P))
(BPFS B)))
(AND (GETU B (QUOTE FOUT))
(PUTU B (QUOTE FOUT)
NIL))
(LRU-TAG B)
(PUT B P Q])
(TAG-DOMAIN
[LAMBDA NIL
(MAPC (APPLY* (QUOTE IN-DOM-OF)
CS-B)
(FUNCTION (LAMBDA (B1)
(OR (AND (SETQ TMP2 (GETB B1 (QUOTE EXS)))
[SOME TMP2 (FUNCTION (LAMBDA (Z)
(MATCH Z WITH ('COMMENT 'EXS 'OF 'YOUR 'DOMAIN 'ARE 'ON TMP3←$]
(NCONC1 Z CS-B))
(INCRB B1 (QUOTE EXS)
(NCONC1 (COPY (COMMENT EXS OF YOUR DOMAIN ARE ON))
CS-B])
(TAG-RANGE
[LAMBDA NIL
(MAPC (APPLY* (QUOTE IN-RAN-OF)
CS-B)
(FUNCTION (LAMBDA (B1)
(OR (AND (SETQ TMP2 (GETB B1 (QUOTE EXS)))
[SOME TMP2 (FUNCTION (LAMBDA (Z)
(MATCH Z WITH ('COMMENT 'EXS 'OF 'YOUR 'RANGE 'ARE 'ON TMP3←$]
(NCONC1 Z CS-B))
(INCRB B1 (QUOTE EXS)
(NCONC1 (COPY (COMMENT EXS OF YOUR RANGE ARE ON))
CS-B])
(TLOOP
[LAMBDA NIL
(CPRIN1 0 "Verbosity Level (0 - 10) .... ")
(SETQ VERBOSITY (RATOM))
(COND
((AND (NUMBERP VERBOSITY)
(ILESSP VERBOSITY 100)))
(T (SETQ VERBOSITY 1)
(TERPRI)
(PRIN1 "No, no!! You must type in an integer, between 1 and 10!!")
(TLOOP)))
(PROG NIL
L1 (PICK-CAND)
(XEQ-CAND)
(UPDATE)
(GO L1])
(TYPE
[NLAMBDA X
(EVAL (CAR (FLAST X])
(UNDO-INIT
[LAMBDA (P L)
(COND
((GETP P (QUOTE UNDO-INIT))
(APPLY* (GETP P (QUOTE UNDO-INIT))
L))
(L])
(UNFORGETTABLE
[LAMBDA (B P I F ARG1)
(* Each C-SUGGESTS part is ordered: first, when to definitely reject recognition;
next, when to definitely accept it. If it accepts, the being decides on part P, interest level I,
function to do to it F, and then returns (I F (B P args)))
(APPLYB B (QUOTE SUGG)
INTHRESH])
(UNPRUNABLE
[LAMBDA (C)
(ILESSP INTHRESH (CAR C])
(UP-THRESH
[LAMBDA NIL
(SETQ DO-THRESH (AVG2 DO-THRESH (CINT CAND])
(UPDATE
[LAMBDA NIL
(UP-THRESH)
(SETQ INTHRESH (IN-FACTOR DO-THRESH))
(CPRIN1 9 CRLF "The final value returned by this candidate was: " CVAL CRLF)
(PRUNE INTHRESH)
(SETQ PAST (CONS (CONS (CDR CAND)
CVAL)
(DREMOVE (CAR (FLAST PAST))
PAST)))
(SETQ GCNT (ADD1 GCNT])
(XEQ-CAND
[LAMBDA NIL
(SETQ CVAL (EVAL CS-ACT])
(XTR-AC-EX
[LAMBDA (L)
(MAPCAR L (QUOTE EXA])
(XTR-BEING
[LAMBDA (B) (* This actually will depend on the
format of the part being worked on.
This part is to be assigned to the
variable XTR-PART)
(COND
((ATOM B)
(AND (GETHASH B HCON)
(LIST B)))
((LISTP B)
(COND
((EQUAL (CAR B)
(QUOTE OR-RUN:))
(EVAL (CADR B)))
(T (MAPCONC B (QUOTE XTR-BEING])
)
(DEFINEQ
(INIT1
[LAMBDA NIL
(CLDISABLE (QUOTE -))
(WIDEPAPER T)
(RAISE)
[INTERRUPTCHAR 24 (QUOTE (PROGN (TERPRI)
(PRIN1 " *** BACKTRACING:")
(TERPRI)
(AM-BT)
(TERPRI)
(PRIN1 "*** END OF BACKTRACE")
(TERPRI]
[INTERRUPTCHAR 25 (QUOTE (PROGN (TERPRI)
(PRIN1 " *** NUMBER OF CANDS IS ")
(PRINT (LENGTH CANDS]
(INTERRUPTCHAR 9 (QUOTE (HANDLE-I-INTERRUPT)))
[INTERRUPTCHAR 26 (QUOTE (PROGN (TERPRI)
(PRIN1 " *** INTEREST ")
(PRIN1 DO-THRESH)
(PRIN1 ", ")
(PRIN1 INTHRESH)
(PRIN1 ", NCANDS=")
(PRIN1 (LENGTH CANDS))
(PRIN1 ", CAND=")
(PRINT CAND]
(TERPRI)
(PRIN1 "YOU PROBABLY WANT TO LOAD IN THE FILE CON4 NOW")
(RANDSET RANDSTATE)
(TERPRI])
(INIT-COMP
[LAMBDA NIL
[COND
((NOT (GETD (QUOTE GETTOPVAL)))
(MOVD (QUOTE CAR)
(QUOTE GETTOPVAL))
(MOVD (QUOTE CDR)
(QUOTE GETPROPLIST))
[PUTD (QUOTE SETTOPVAL)
(QUOTE (LAMBDA (X Y)
(CAR (FRPLACA X Y]
[PUTD (QUOTE SETPROPLIST)
(QUOTE (LAMBDA (X Y)
(CDR (FRPLACD X Y]
[PUTD (QUOTE /SETTOPVAL)
(QUOTE (LAMBDA (X Y)
(CAR (/RPLACA X Y]
[PUTD (QUOTE /SETPROPLIST)
(QUOTE (LAMBDA (X Y)
(CDR (/RPLACD X Y]
(NCONC LISPXFNS (QUOTE ((SETTOPVAL . /SETTOPVAL)
(SETPROPLIST . /SETPROPLIST]
[COND
((NOT (GETD (QUOTE GETFILEPTR)))
(MOVD (QUOTE SFPTR)
(QUOTE GETFILEPTR))
(PUTD (QUOTE SETFILEPTR)
(QUOTE (LAMBDA (FILE PTR)
(PROG1 PTR (SFPTR FILE PTR]
(DEFLIST [QUOTE ((GETTOPVAL ((X)
(CAR X)))
(GETPROPLIST ((X)
(CDR X]
(QUOTE MACRO])
)
(RPAQQ BA-LIST (BA1 BA2 BA3 BA4 BA5 BA6 BA7 BA8 BA9))
(RPAQQ BA-LIST2 (BA1 BA2 BA3))
[RPAQQ CAND-TAIL ((0 PRINT (QUOTE TAIL-MARK]
(RPAQQ COMMA ", ")
(RPAQQ CONSTRUCTIVE-OPS (STRUCTURE-INSERT UNION NCONC ATTACH MAPSTRUC CONS UNITE APPEND LIST))
(RPAQQ CRLF "
")
(RPAQQ DO-THRESH 541)
(RPAQQ DWIMUSERFN T)
(RPAQQ EX-THRESH 500)
(RPAQQ F-COUNTER 0)
(RPAQQ GNUMS (6 5 4 3 2 1))
[RPAQQ INIT-CANDS ((0 PRIN1 (QUOTE TAIL-MARK]
(RPAQQ INIT-ONCE-LIST (ANYB ANYP))
(RPAQQ INIT-PAST ((A B)
(C D)
(E F)
(G H)
(I J)
(K L)
(M N)
(O P)
(Q R)
(S T)
(U V)
(W X)
(Y Z)
(AA BB)
(CC DD)
(EE FF)))
(RPAQQ INIT-DOTHRESH 500)
(RPAQQ INIT-EXTHRESH 500)
(RPAQQ INIT-INT-THRESH 279)
(RPAQQ INIT-INTHRESH 100)
(RPAQQ INT-THRESH 339)
(RPAQQ INTHRESH 108)
(RPAQQ JTRASH (JUST-ONCE (COND)))
(RPAQQ RANDSTATE (-24701620973 . -20850377350))
(RPAQQ TKNT-INIT 20000)
(RPAQQ TOP-ACTS (ACCESS ADD-CANDS APPLYB CHECK EVAL EXPR-IN FILLIN GOAL INIT-PART INSTANTIATE PRIN1 PRINT RE-JUDGE
RESTRUC SUB-CANDS TRANSLATE))
(RPAQQ TRIVB [LAMBDA (BP BA1 BA2 BA3 BA4)
(SELECTQ BP NIL])
(RPAQQ USERNAMES (DOUG ED CORDELL BRUCE DON))
(RPAQQ VERBOSITY 10)
(INIT1)
(INIT-COMP)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA TYPE COMMENT ANY1OF)
(ADDTOVAR NLAML SWITCH SETBQ SELF-COMPILE SELF RE-JUDGE Q JUST-ONCE GETBQ AQ-LIST ANY1SAT ALLQ)
]
(LISPXPRINT (QUOTE TOP4COMS)
T T)
[RPAQQ TOP4COMS
((FNS ACCESS ACEX ACEX-OLD ADD-CANDS ALL-BUT-LAST ALLQ ANY1OF ANY1OF-SATISFYING ANY1OFE ANY1SAT APPENDB APPLYB
APPLYB-P AQ-LIST ARE-EQUIV ARG-CHECK ARG-SUBST ARGS-ASA AVG2 BLOWUP-COALES BLOWUP-INTERESTING-SPEC BOOST
BPFS COM-ANCES COMMENT CON-MERGE-ARGS CPRIN1 CREATEB DE-THRESH DECRB DEFB DEFP DIE DOTPROD DRAND-PERMUTE
DWIMUSERFN ENSURE ENSURE-TOP EVERY2 EXA FAN FIL-ACEX FIL-EX1 FIL-EX2 FIL-STRUC-P FIND-NEW-CANDS FIRSTN
FLATTEN FOU FOU1 FRAC-INCLU FSET-NTH GATH GCB GEN-FNAME GET-TIME GETARGS GETB GETB-P GETB-P-C GETBQ GETU
GEXADD GEXEC GINIT GLUE GLUEC GLUEE GPGM-PRIN GTRANSFER HANDLE-I HANDLE-I-INTERRUPT HANDLE-N IN-FACTOR
INCRB INIT-PART INSTAN-1D INSTAN-1I INSTAN-1S INSTAN-ACT-TRANS INSTAN-BASE INSTAN-D INSTAN-I INSTAN-PAT
INSTAN-REC INSTAN-S INSTAN-TRANSF INT-ENUF INT-PREDS IS-CON IS-CON-L IS-ONE-OF ISA JUST-ONCE KINDS-OF
LARGER LESS-INT LRU-TAG M2 MAPAPPEND MAX MAX1 MAX2 MAXI MIN2 MKSWAPP MORE-GENERAL MORE-INT MORE-SPECIFIC
NCONCB NO-COMMEN ONE-ISA ONLY-COMS PGET PICK-CAND POR PRUNABLE PRUNE PSUF PUTB PUTU PXEQ Q RAND-CON
RAND-MEMB RAND-OBJ RAND-PERMUTE RAND-PRED RAND-SUBSET RAND-THING RAND-USER RANDQMEMB RE-JUDGE READ-LOOP
READ1CHAR RECENTLY-TRIED RECTANGLE REM-ONCE RIPPLE RIPPLE-SIMULT RIPPLE-UNTIL RIPPLE1 RMUL RUN-COMM
RUN-COMM-IF-MUST SAME-TYPE SATISFIES SELF SELF-COMPILE SELF-INT SEQX SET-DIFF SET-DIFFERENCE SET-NTH
SETB SETB-I SETBQ SIMULT-SATISFY SMALLER SOME-EBP SOMEE SORD SORV SSORT START STRUCTYP? SUB-CANDS
SUB-ONCE SUBSET-INVOLVING-ONLY SWAPB SWGETB SWITCH SWSETB TAG-DOMAIN TAG-RANGE TLOOP TYPE UNDO-INIT
UNFORGETTABLE UNPRUNABLE UP-THRESH UPDATE XEQ-CAND XTR-AC-EX XTR-BEING)
(FNS INIT1 INIT-COMP)
BA-LIST BA-LIST2 CAND-TAIL COMMA CONSTRUCTIVE-OPS CRLF DO-THRESH DWIMUSERFN EX-THRESH F-COUNTER GNUMS
INIT-CANDS INIT-ONCE-LIST INIT-PAST INIT-DOTHRESH INIT-EXTHRESH INIT-INT-THRESH INIT-INTHRESH INT-THRESH
INTHRESH JTRASH RANDSTATE TKNT-INIT TOP-ACTS TRIVB USERNAMES VERBOSITY (P (INIT1)
(INIT-COMP))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA TYPE COMMENT ANY1OF)
(NLAML SWITCH SETBQ SELF-COMPILE SELF RE-JUDGE Q JUST-ONCE GETBQ AQ-LIST ANY1SAT ALLQ ACEX]
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA TYPE COMMENT ANY1OF)
(ADDTOVAR NLAML SWITCH SETBQ SELF-COMPILE SELF RE-JUDGE Q JUST-ONCE GETBQ AQ-LIST ANY1SAT ALLQ ACEX)
]
(DECLARE: DONTCOPY
(FILEMAP (NIL (2665 51422 (ACCESS 2677 . 2708) (ACEX 2712 . 3131) (ACEX-OLD 3135 . 3283) (ADD-CANDS 3287 . 3346) (
ALL-BUT-LAST 3350 . 3403) (ALLQ 3407 . 3529) (ANY1OF 3533 . 3664) (ANY1OF-SATISFYING 3668 . 3840) (ANY1OFE 3844 .
3881) (ANY1SAT 3885 . 3968) (APPENDB 3972 . 4056) (APPLYB-P 4060 . 4119) (AQ-LIST 4123 . 4237) (ARE-EQUIV 4241 . 4831)
(ARG-CHECK 4835 . 4936) (ARG-SUBST 4940 . 5392) (ARGS-ASA 5396 . 5700) (AVG2 5704 . 5771) (BLOWUP-COALES 5775 . 8429)
(BLOWUP-INTERESTING-SPEC 8433 . 10618) (BOOST 10622 . 10702) (BPFS 10706 . 10754) (COM-ANCES 10758 . 10995) (COMMENT
10999 . 11056) (CON-MERGE-ARGS 11060 . 13400) (CPRIN1 13404 . 13529) (CREATEB 13533 . 13768) (DE-THRESH 13772 . 13937)
(DECRB 13941 . 14001) (DEFB 14005 . 14532) (DEFP 14536 . 15204) (DIE 15208 . 15333) (DOTPROD 15337 . 15480) (
DRAND-PERMUTE 15484 . 15593) (DWIMUSERFN 15597 . 15953) (ENSURE 15957 . 16244) (ENSURE-TOP 16248 . 16698) (EVERY2
16702 . 16850) (EXA 16854 . 17036) (FAN 17040 . 17154) (FIL-ACEX 17158 . 17311) (FIL-EX1 17315 . 17570) (FIL-EX2 17574
. 19202) (FIL-STRUC-P 19206 . 19634) (FIND-NEW-CANDS 19638 . 19812) (FIRSTN 19816 . 19872) (FLATTEN 19876 . 19977)
(FOU 19981 . 20034) (FOU1 20038 . 20089) (FRAC-INCLU 20093 . 20354) (FSET-NTH 20358 . 20425) (GATH 20429 . 20791)
(GCB 20795 . 21091) (GEN-FNAME 21095 . 21222) (GET-TIME 21226 . 21277) (GETARGS 21281 . 21331) (GETB 21335 . 21387)
(GETB-P 21391 . 21430) (GETB-P-C 21434 . 21481) (GETBQ 21485 . 21526) (GETU 21530 . 21589) (GEXADD 21593 . 21666)
(GEXEC 21670 . 21717) (GINIT 21721 . 21777) (GLUE 21781 . 21987) (GLUEC 21991 . 22077) (GLUEE 22081 . 22290) (GPGM-PRIN
22294 . 22766) (GTRANSFER 22770 . 22914) (HANDLE-I 22918 . 22968) (HANDLE-I-INTERRUPT 22972 . 23450) (HANDLE-N 23454
. 23500) (IN-FACTOR 23504 . 23551) (INCRB 23555 . 23757) (INIT-PART 23761 . 23837) (INSTAN-1D 23841 . 25882) (INSTAN-1I
25886 . 25938) (INSTAN-1S 25942 . 25978) (INSTAN-ACT-TRANS 25982 . 27235) (INSTAN-BASE 27239 . 27554) (INSTAN-D 27558
. 27619) (INSTAN-I 27623 . 27697) (INSTAN-PAT 27701 . 28326) (INSTAN-REC 28330 . 29175) (INSTAN-S 29179 . 29253) (
INSTAN-TRANSF 29257 . 30632) (INT-ENUF 30636 . 31198) (INT-PREDS 31202 . 31435) (IS-CON 31439 . 31484) (IS-CON-L 31488
. 31552) (IS-ONE-OF 31556 . 31719) (ISA 31723 . 31890) (JUST-ONCE 31894 . 32013) (KINDS-OF 32017 . 32160) (LARGER
32164 . 32237) (LESS-INT 32241 . 32303) (LRU-TAG 32307 . 32397) (M2 32401 . 32550) (MAPAPPEND 32554 . 32633) (MAX
32637 . 32733) (MAX1 32737 . 32852) (MAX2 32856 . 33108) (MAXI 33112 . 33407) (MIN2 33411 . 33654) (MKSWAPP 33658
. 33729) (MORE-GENERAL 33733 . 33890) (MORE-INT 33894 . 33962) (MORE-SPECIFIC 33966 . 34124) (NCONCB 34128 . 34226)
(NO-COMMEN 34230 . 34314) (ONE-ISA 34318 . 34415) (ONLY-COMS 34419 . 34526) (PGET 34530 . 34631) (PICK-CAND 34635
. 35727) (POR 35731 . 35917) (PRUNABLE 35921 . 35982) (PRUNE 35986 . 36058) (PSUF 36062 . 36709) (PUTB 36713 . 36796)
(PUTU 36800 . 36940) (PXEQ 36944 . 37452) (Q 37456 . 37507) (RAND-CON 37511 . 37572) (RAND-MEMB 37576 . 37657) (RAND-OBJ
37661 . 37754) (RAND-PERMUTE 37758 . 38040) (RAND-PRED 38044 . 38093) (RAND-SUBSET 38097 . 38158) (RAND-THING 38162
. 38221) (RAND-USER 38225 . 38287) (RANDQMEMB 38291 . 38379) (RE-JUDGE 38383 . 38604) (READ-LOOP 38608 . 38689) (
READ1CHAR 38693 . 39032) (RECENTLY-TRIED 39036 . 39100) (RECTANGLE 39104 . 39386) (REM-ONCE 39390 . 39524) (RIPPLE
39528 . 39886) (RIPPLE-SIMULT 39890 . 40386) (RIPPLE-UNTIL 40390 . 40905) (RIPPLE1 40909 . 41223) (RMUL 41227 . 41301)
(RUN-COMM 41305 . 41532) (RUN-COMM-IF-MUST 41536 . 42036) (SAME-TYPE 42040 . 42168) (SATISFIES 42172 . 42203) (SELF
42207 . 42244) (SELF-COMPILE 42248 . 42458) (SELF-INT 42462 . 42511) (SEQX 42515 . 42650) (SET-DIFF 42654 . 42852)
(SET-DIFFERENCE 42856 . 42963) (SET-NTH 42967 . 43177) (SETB 43181 . 43469) (SETB-I 43473 . 43543) (SETBQ 43547 .
43598) (SIMULT-SATISFY 43602 . 44921) (SMALLER 44925 . 44999) (SOME-EBP 45003 . 45170) (SOMEE 45174 . 45360) (SORD
45364 . 45604) (SORV 45608 . 45678) (SSORT 45682 . 45740) (START 45744 . 46247) (STRUCTYP? 46251 . 46886) (SUB-CANDS
46890 . 47191) (SUB-ONCE 47195 . 47342) (SUBSET-INVOLVING-ONLY 47346 . 47527) (SWAPB 47531 . 47814) (SWGETB 47818
. 48162) (SWITCH 48166 . 48272) (SWSETB 48276 . 48661) (TAG-DOMAIN 48665 . 49053) (TAG-RANGE 49057 . 49442) (TLOOP
49446 . 49847) (TYPE 49851 . 49897) (UNDO-INIT 49901 . 50030) (UNFORGETTABLE 50034 . 50384) (UNPRUNABLE 50388 . 50445)
(UP-THRESH 50449 . 50524) (UPDATE 50528 . 50849) (XEQ-CAND 50853 . 50908) (XTR-AC-EX 50912 . 50965) (XTR-BEING 50969
. 51419)) (51424 53187 (INIT1 51436 . 52264) (INIT-COMP 52268 . 53184)))))
STOP